perm filename SCANNR.SAI[PNT,HE]1 blob sn#463372 filedate 1979-08-05 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00008 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	IFCR NOT DECLARATION($$PRGID) THENC 
C00003 00003	! scanning routines
C00004 00004	! pop,mty, push devstack
C00006 00005	! expandmacro
C00009 00006	! parse: number,nums,GTOKEN,namefile 
C00019 00007	INTERNAL SIMPLE  PROCEDURE SEMICOL_READ
C00023 00008	! input from different sources 
C00027 ENDMK
C⊗;
IFCR NOT DECLARATION($$PRGID) THENC 
ENTRY;
BEGIN "SCANNER"		 ENDC
DEFINE $SCANNER = TRUE ;

REQUIRE "HEADER.SAI" SOURCE_FILE;

! scanning routines;

STRING PROCEDURE SSCAN(REFERENCE STRING SOURCE; INTEGER BRK; REFERENCE INTEGER BRCHR);
BEGIN
	STRING S1,SS;
	INTEGER L;
	S1←SOURCE;
	SS←SCAN(SOURCE,BRK,BRCHR);
	IF (L←LENGTH(S1)-LENGTH(SOURCE))>0 THEN
		$CLNSAVE←$CLNSAVE&SS[1 TO L];
	RETURN(SS);
END;
! pop,mty, push devstack;
RCLASS DEVSTACK(INTEGER DEV,DSKCHN; STRING $CLNE,$CLINR,$CRBODY;
		RPTR(DEVSTACK)NEXT);
RPTR(DEVSTACK) DEVSTACKTOP;

STRING $CRBODY;

INTERNAL PROCEDURE POPDEVSTACK;
BEGIN
	IF DEVSTACKTOP=NULL_RECORD THEN ERROR("cant pop device stack, already at bottom");
	IF DEVICE=DSK_X THEN  RELEASE($INPCH);
	DEVICE←DEVSTACK:DEV[DEVSTACKTOP];
	IF DEVICE=DSK_X THEN BEGIN $INPCH←DEVSTACK:DSKCHN[DEVSTACKTOP]; $EOF←FALSE; END;
	$CLNE←DEVSTACK:$CLNE[DEVSTACKTOP];
	$CLINR←DEVSTACK:$CLINR[DEVSTACKTOP];
	$CRBODY←DEVSTACK:$CRBODY[DEVSTACKTOP];
	DEVSTACKTOP←DEVSTACK:NEXT[DEVSTACKTOP];
END;

INTERNAL PROCEDURE MTYDEVSTACK;
BEGIN	BOOLEAN FLAG; STRING S;
	WHILE DEVSTACKTOP≠NULL_RECORD DO POPDEVSTACK;
	DO S←INCHSL(FLAG) UNTIL FLAG=TRUE;	! CLEARS TYPEAHEAD ;
	$CLNE←$CLINR←$CRBODY←NULL;
	DEVICE←TTY_X;
END;

INTERNAL PROCEDURE PUSHDEVSTACK;
BEGIN
	RPTR(DEVSTACK) D1;
	D1←NEW_RECORD(DEVSTACK);
	IF (DEVSTACK:DEV[D1]←DEVICE)=DSK_X THEN
			BEGIN  DEVSTACK:DSKCHN[D1]←$INPCH;
				$INPCH← - 1; END;
	DEVSTACK:$CLNE[D1]←$CLNE;
	DEVSTACK:$CLINR[D1]←$CLINR;
	DEVSTACK:$CRBODY[D1]←$CRBODY;
	$CLNE←$CLINR←$CRBODY←NULL;
	DEVSTACK:NEXT[D1]←DEVSTACKTOP;
	DEVSTACKTOP←D1;
END;
! expandmacro;

INTEGER DUMMYDL;
PROCEDURE BTINIT;
	SETBREAK(DUMMYDL←GETBREAK,DUMMY_DELIM,NULL,"IS");
REQUIRE BTINIT INITIALIZATION;

STRING PROCEDURE EXPANDPROC(RPTR(SYMBOL)S1);
BEGIN	RPTR(MACRO) MOT;
        STRING PARAM,CRBODY,CURBODY;
	INTEGER BRCHAR,DLCOUNT,NPARAM;
	
	STRING SAV$CLNSAV;
	SAV$CLNSAV←$CLNSAVE[1 TO ∞ - LENGTH(TOKEN)];

	NOEXPAND ← TRUE;
	IF (NPARAM←MACRO:NPARAM[MOT←SYMBOL:OBJECT[S1]])≠ 0
	    THEN  α "parametered macro"
		STRING ARRAY ACTPRMS[1:NPARAM]; INTEGER I;
		WORD_READ("(");

		FOR I←1 STEP 1 UNTIL NPARAM
		DO  α "count parameters"
		    GTOKEN;
		    IF EQU(TOKEN,"⊂")
			THEN  α INTEGER J; STRING TTOKEN;
			    DLCOUNT ← 1; TTOKEN←NULL;
			    DO α
			    J←READTILL("⊂⊃");
			    TTOKEN←TTOKEN&TOKEN&J;
			    IF J = "⊂"
				THEN DLCOUNT ← DLCOUNT + 1
				ELSE DLCOUNT ← DLCOUNT - 1;
			    β UNTIL DLCOUNT=0;
			    ACTPRMS[I]←TTOKEN[1 TO ∞-1];
			    β
		 	ELSE ACTPRMS[I]←TOKEN;
		    GTOKEN;
				
		    IF TOKEN≠"," AND I<NPARAM THEN
			ERROR("MACRO EXPANSION: comma expected here");
		    β "count parameters";

		IF TOKEN≠")"
		   THEN ERROR("MACRO EXPANSION: mismatched number of parameters");
		CRBODY ← NULL;
	        CURBODY ← MACRO:BODY[MOT];
		WHILE NOT EQU(CURBODY,NULL)
		DO α	INTEGER I;
			CRBODY←CRBODY&SCAN(CURBODY,DUMMYDL,BRCHAR);
			PARAM←SCAN(CURBODY,DUMMYDL,BRCHAR);
			FOR I←1 STEP 1 UNTIL MACRO:NPARAM[MOT] DO
			    IF EQU(PARAM,MACRO:PRLIST[MOT][I]) THEN
				α PARAM←ACTPRMS[I];DONE; β;
			IF I>MACRO:NPARAM[MOT] AND BRCHAR≠0
				THEN ERROR("EXPANDMACRO ERROR: ????");
			CRBODY ← CRBODY & PARAM;
			β;
		β "parametered macro"
	    ELSE CRBODY ← MACRO:BODY[MOT];
	NOEXPAND ← FALSE;
	$CLNSAVE←SAV$CLNSAV;
	RETURN(CRBODY);
END;
! parse: number,nums,GTOKEN,namefile ;

	! checks if num is a number or @;

SIMPLE  BOOLEAN PROCEDURE NUMBER(INTEGER NUM);	
	RETURN( "0"≤NUM≤"9" OR NUM="@");

	! checks if the string word contains  only numbers;

SIMPLE  BOOLEAN PROCEDURE NUMS(STRING WORD);	
	BEGIN	"NS"
	STRING WW; INTEGER BR;
	WW←SCAN(WORD,$NUMTAB,BR);
	IF BR=0 THEN RETURN (TRUE) ELSE RETURN (FALSE);
	END "NS";

	! returns true if the last TOKEN is a terminal character, CR or ;
INTERNAL SIMPLE  BOOLEAN PROCEDURE FINAL;
RETURN(TOKEN=SEMC OR TOKEN=CR OR TOKEN=NULL);

	! ignores input up to and including the next occurence of CHAR;
INTERNAL SIMPLE PROCEDURE READTO(STRING CHAR);
	BEGIN INTEGER I,BRCHAR; STRING R;
	SETBREAK(I←GETBREAK, CHAR, NULL, "IA");
	R←SSCAN($CLINR,I,BRCHAR);
	WHILE BRCHAR≠CHAR DO BEGIN NEWLINE; R←SCAN($CLINR,I,BRCHAR); END;
	RELBREAK(I);
	END;

	! returns in TOKEN the string upto but not including characters in CHARS:
	The break character is retained in the input string;
INTERNAL SIMPLE INTEGER PROCEDURE READTILL(STRING CHARS);
	BEGIN INTEGER I,BRCHAR; STRING R;
	SETBREAK(I←GETBREAK, CHARS, NULL, "IS");
	R←SSCAN($CLINR,I,BRCHAR);
	WHILE BRCHAR=NULL DO BEGIN NEWLINE; R←R&CRLF&SSCAN($CLINR,I,BRCHAR); END;
	RELBREAK(I); TOKEN←R;
	RETURN(BRCHAR);
	END;

INTERNAL RECURSIVE PROCEDURE GTOKEN (BOOLEAN MUSTGETTOKEN(TRUE));
	BEGIN "GTOKEN"
	STRING WORD,WORD2;
	INTEGER BRPARS; LABEL AGAIN; BOOLEAN NONSTOP;

	! reads next RTOKEN using the indicated breaktable;
	REQUIRE "<><>" DELIMITERS;
   define rtoken(aaa)=<scan($CLINR, aaa ,brpars)>;
   define rstoken(aaa)=<sscan($CLINR, aaa ,brpars)>;

	IF STOKEN THEN BEGIN STOKEN←FALSE;RETURN;END;
	tokenlevel←tokenclass←tokenindex←0;
	NONSTOP←MUSTGETTOKEN OR (DEVICE=DSK_X);
AGAIN: 	IF NONSTOP THEN WHILE $CLINR=NULL DO NEWLINE;
	WORD←NULL; #TOKEN←UNDECLARED_TYPE;
	RSTOKEN($SPCTAB);				! skips blanks;
	WORD←WORD&RSTOKEN($RETAB);		! reads first RTOKEN;
	IF WORD=NULL 
	    THEN IF BRPARS="." 
		THEN  BEGIN			! no object read, period found;
			RSTOKEN($SKTAB);
			RSTOKEN($ALFTAB);	! reads one character;
			IF NUMBER(BRPARS)
			THEN BEGIN
				WORD←"."&RSTOKEN($NUMTAB); ! reads until finds numbers;
				#TOKEN  ←REAL_TYPE;	! floating number read;
				END
			ELSE BEGIN
				WORD←".";
				#TOKEN  ←OPERATOR_TYPE;	! period is only a punctuation mark;
				END;
			END
		ELSE  IF (BRPARS=CR or BRPARS=NULL) AND NONSTOP
			THEN BEGIN
			NEWLINE;
			GO TO  AGAIN;
			END
		ELSE IF BRPARS="{"
			THEN BEGIN "comment found"
			READTO("}");
			GO TO AGAIN;
			END
		ELSE IF BRPARS="⊗"
			THEN BEGIN
			WORD←OLDOBJ;
			RSTOKEN($SKTAB);
			#TOKEN←ID_TYPE;
			END
			ELSE BEGIN
				WORD←BRPARS;
				RSTOKEN($SKTAB);
				#TOKEN  ←OPERATOR_TYPE;		! punctuation mark found;
				END
		ELSE IF BRPARS="."  
			THEN IF NUMS(WORD) 
                           THEN BEGIN     
				WORD←WORD&".";           
				RSTOKEN($SKTAB);
				RSTOKEN($ALFTAB); 	! reads one character;
				IF NUMBER(BRPARS)                       
				THEN WORD←WORD&RSTOKEN($NUMTAB);
					 		! there are more numbers;
				#TOKEN  ←REAL_TYPE;	! floating number read;
				END;
	TOKEN←WORD;
	! checks if RTOKEN is an integer number;
	IF TOKEN
	   THEN
	IF #TOKEN  =UNDECLARED_TYPE 
	    THEN BEGIN
	        WORD2←SSCAN(WORD,$ALFTAB,BRPARS);	! reads one character;
	        IF NUMBER(BRPARS) 
	           THEN BEGIN				! if first ch. is a number;
	                WORD2←SSCAN(WORD,$NUMTAB,BRPARS);
	                IF BRPARS=0 
	                   THEN BEGIN			! only numbers found;
	                        #TOKEN  ←INT_TYPE;		! integer number read;
				TOKEN←WORD2;
	                        END
	                   ELSE BEGIN
				TOKEN←NULL;		! incorrect TOKEN;
	                        ERROR ($SYNMSG[31],NULL);
	                        END
	                END;
	        END;
	IF #TOKEN=UNDECLARED_TYPE
	   THEN IF DECSTR(TOKEN)≠0
		THEN #TOKEN←RES_TYPE
		ELSE begin "check for id"
			RPTR(SYMBOL)S; RPTR(BLOCKREC)BR;
			IF CURPROC THEN
			    IF EQU(TOKEN,SYMBOL:PNAME[CURPROC])
				THEN BEGIN #TOKEN←ID_TYPE;TOKENPTR←CURPROC;
				RETURN; END;
			BR←CURBLOCK;
			WHILE BR DO
			      BEGIN "check local variables"
			      S←SEARCHBLOCK(TOKEN,BR);
			      IF S THEN BEGIN #TOKEN←ID_TYPE;
				TOKENPTR←S; TOKENLEVEL←BLOCKREC:LEVEL[BR];
				TOKENINDEX←SYMBOL:TYPE[S]; RETURN; END;
			      BR←BLOCKREC:NEXT[BR];
			      END "check local variables";
			IF #TOKEN=UNDECLARED_TYPE THEN
			IF (TOKENPTR←CHECKTOT(TOKEN))≠NULL_RECORD
			THEN BEGIN #TOKEN←ID_TYPE; 
				IF (TOKENINDEX←SYMBOL:TYPE[TOKENPTR])=#MC
				    AND ¬NOEXPAND THEN
					BEGIN STRING SSS;
					SSS←EXPANDPROC(TOKENPTR);
					PUSHDEVSTACK;
					$CRBODY←SSS;
					DEVICE←MAC_X;
					GTOKEN;
					END;
			    END;
			end "check for id";
	END "GTOKEN";
	! reads a file name and returns it ;

INTERNAL STRING PROCEDURE NAMEFILE;
	BEGIN "NAMEFILE"
	STRING NAME;
	GTOKEN; 

	NAME←TOKEN;				! name of file;
	GTOKEN(FALSE);
	IF #TOKEN =REAL_TYPE
	    THEN IF TOKEN="."
		THEN BEGIN NAME←NAME&TOKEN; GTOKEN(FALSE); END
		ELSE ERROR($SYNMSG[21],$SYNMSG[25])
	    ELSE IF EQU(TOKEN,".")
		THEN BEGIN "EXT"			! extension;
		    GTOKEN; NAME←NAME&"."&TOKEN; GTOKEN(FALSE);
		    END "EXT";

	IF TOKEN="["
	    THEN BEGIN "PPN"		! there is ppn;
		GTOKEN;			
		NAME←NAME&"["&TOKEN; GTOKEN(FALSE);
		IF TOKEN=","
		    THEN BEGIN "PN"
			GTOKEN(FALSE);		! there is pn;
			IF TOKEN=NULL THEN RETURN(NAME);
			NAME←NAME&","&TOKEN;
			GTOKEN(FALSE);
			IF TOKEN="]" OR TOKEN=NULL THEN NAME←NAME&"]"
			    ELSE ERROR($SYNMSG[4],$SYNMSG[25]);
			END "PN"
		ELSE IF TOKEN=NULL
		    THEN RETURN(NAME)
		    ELSE ERROR($SYNMSG[1],$SYNMSG[25]);
		END "PPN"
	    ELSE STOKEN←TRUE;
	RETURN(NAME);
	END "NAMEFILE";
INTERNAL SIMPLE  PROCEDURE SEMICOL_READ;
	BEGIN
	GTOKEN(FALSE);
	IF NOT FINAL THEN ERROR($SYNMSG[0],$SYNMSG[25]);
	END;

INTERNAL SIMPLE  PROCEDURE WORD_READ(STRING S);
	BEGIN
	GTOKEN;
	IF NOT EQU(TOKEN,S) THEN ERROR("----→ "&S&" required ←-----");
	END;


INTERNAL SIMPLE  STRING PROCEDURE IDF_READ;
	BEGIN
	GTOKEN;
	IF #TOKEN  =INT_TYPE OR #TOKEN=REAL_TYPE OR #TOKEN=OPERATOR_TYPE
	    THEN ERROR($SYNMSG[21],$SYNMSG[25])
	    ELSE RETURN(TOKEN);
	END;

INTERNAL SIMPLE STRING PROCEDURE MVFR_READ;
	BEGIN
 	GTOKEN;
	IF EQU(TOKEN,"BY") 
	   THEN BEGIN STOKEN←TRUE; RETURN("BARM"); END
	   ELSE IF #TOKEN=ID_TYPE
		THEN RETURN(TOKEN)
		ELSE ERROR($SYNMSG[21],$SYNMSG[25]);
	END;
		
INTERNAL SIMPLE  STRING PROCEDURE HAND_READ;
	BEGIN				! reads BHAND or YHAND (default= BHAND);
	GTOKEN;
	IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND") 
	   THEN RETURN(TOKEN)
	   ELSE IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
		THEN BEGIN STOKEN←TRUE; RETURN("BHAND"); END
		ELSE ERROR($SYNMSG[19],$SYNMSG[25]);
	END;

INTERNAL SIMPLE  STRING PROCEDURE ARM_READ;
	BEGIN		! reads "BARM" or "YARM" (default=BARM);
	GTOKEN(FALSE);
	IF EQU(TOKEN,"YARM") OR EQU(TOKEN,"BARM") 
	   THEN RETURN(TOKEN)
	   ELSE IF TOKEN=";" OR FINAL
		THEN BEGIN STOKEN←TRUE; RETURN("BARM"); END
		ELSE ERROR($SYNMSG[18],$SYNMSG[25]);
	END;

INTERNAL SIMPLE STRING PROCEDURE DEV_READ;
	BEGIN		! reads BARM/YARM/POINTER (default=POINTER);
	GTOKEN(FALSE);
	IF EQU(TOKEN,"POINTER") OR EQU(TOKEN,"BARM") OR EQU(TOKEN,"YARM")
	   THEN RETURN(TOKEN)
	   ELSE IF FINAL OR TOKEN=";" THEN
	   	BEGIN STOKEN←TRUE; RETURN("POINTER") END
		ELSE BEGIN
		    PRINT($SYNMSG[18],"OR POINTER ",$SYNMSG[25]," OR",CRLF);
		    ERROR($SYNMSG[0],$SYNMSG[25]);
		    END;
	END;

	! returns the FROM frame  "{FROM <frame>}" or STATION;
INTERNAL SIMPLE	STRING PROCEDURE FROMPART;
	BEGIN
	STRING ROOT;
        GTOKEN(FALSE);
	IF EQU(TOKEN,"FROM")
	   THEN BEGIN ROOT←IDF_READ; RETURN(ROOT); END
	   ELSE	IF FINAL 
		THEN RETURN("STATION")
		ELSE BEGIN
			PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
			ERROR("--→ FROM ",$SYNMSG[25]);
			END;
	END;
! input from different sources ;
INTERNAL PROCEDURE ASKUSER(STRING S(NULL));
BEGIN
	PUSHDEVSTACK;
	IF S=NULL 
	    THEN BEGIN $CLNE←$CLINR←INCHWL; DEVICE←QUERY_X; END
	    ELSE BEGIN $CLNE←$CLINR←NULL; $CRBODY←S; DEVICE←PROGRAM_X; END;
END;

INTEGER $CVRTBREAK;
PROCEDURE INITCVRT;
	SETBREAK($CVRTBREAK←GETBREAK,NULL,NULL,"K");
REQUIRE INITCVRT INITIALIZATION;

STRING PROCEDURE LISPMESS;
BEGIN
DEFINE MAIL = "710000000000";
STRING STR;INTEGER I;
INTEGER ARRAY MESS[1:32];
  STR←NULL;
  DO BEGIN
    START_CODE
      MAIL 1,ACCESS(MESS[1]);
    END;
    FOR I←1 STEP 1 UNTIL 31 DO STR←STR&CVASTR(MESS[I]);
    END UNTIL MESS[32]=0;
  RETURN(SCAN(STR,$CVRTBREAK,I));
END;

INTEGER TTYLINES;

INTERNAL PROCEDURE NEWLINE;
BEGIN
	CHKESC_I;
	CASE DEVICE OF
	BEGIN
	[QUERY_X] [MAC_X] [PROGRAM_X]
		BEGIN
		INTEGER BRCHAR;
		IF $CRBODY THEN $CLNE←$CLINR←SCAN($CRBODY,$CRTAB,BRCHAR)
			ELSE POPDEVSTACK;
		END;
		
	[TTY_X]	BEGIN
		IF STBEGIN THEN OUTSTR("* ") ELSE OUTSTR("***>>> ");
		$CLNE←$CLINR←INCHWL;
		IF $OUT THEN 
		    BEGIN CPRINT($TTYCH,$CLNE,CRLF);
			  IF TTYLINES≥6 THEN 
				BEGIN UDATEFILE($TTYCH); TTYLINES←0; END
			  ELSE TTYLINES←TTYLINES+1;
		    END;
		END;

	[DSK_X]	IF $EOF
		THEN	BEGIN $ALLOW←0; RELEASE($INPCH);
			POPDEVSTACK; UPDATE;
			END
		ELSE 	BEGIN
			$CLNE←$CLINR←INPUT($INPCH,$CRTAB);
			IF NEWFILE THEN
				BEGIN IF $CLNE[1 TO 17] =
					"COMMENT ⊗   VALID"
					THEN $CLNE←INPUT($INPCH,$FFTAB);
					$CLNE←$CLINR←INPUT($INPCH,$CRTAB);
					NEWFILE←FALSE;
				END;
			IF FILEPRINT THEN PRINT(CRLF,$CLNE);
			END;

	[MESSAGE_X]
		BEGIN
		OUTSTR("WAITING FOR MAIL... ");
		$CLNE←$CLINR←LISPMESS;
		OUTSTR("MAIL RECEIVED: "&$clne&crlf);
		IF $OUT THEN BEGIN CPRINT($TTYCH,"{mail received}",$CLNE,CRLF);
		IF TTYLINES≥6 THEN BEGIN UDATEFILE($TTYCH); TTYLINES←0; END
			ELSE TTYLINES←TTYLINES+1;
			    END;
		END;

	ELSE	BEGIN MTYDEVSTACK; ERROR("NO SUCH DEVICE"); END
	END;
END;
END "SCANNER";